Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Applications/TCPExample/PNL Libraries/TCPUtils.p

Text File | 1997-04-01 | 13.2 KB | 499 lines | [TEXT/CWIE]

unit TCPUtils;

interface

    uses
        Types, TCPTypes;

    var
        mactcp_driver_refnum:integer;

    type
        TCPXControlBlock = record
                completion: ProcPtr;
                pb: TCPControlBlock;
            end;
        TCPXControlBlockPtr = ^TCPXControlBlock;

        TCPStateType = (T_WaitingForOpen, T_Dead, T_Bored, T_Opening, T_Established,
            T_Closing, T_PleaseClose, T_Unknown);
{ T_Bored means listening or closed }

    type
        DNRCompletionProcPtr = ProcPtr;
{ procedure DNRCompletionProc(drp:DNRRecordPtr); }
        DNRRecord = record
{ Generally you only need to look at the first three of these }
                ioResult: OSErr;
                name: Str255;
                addr: longint;
                completion: DNRCompletionProcPtr;
                case integer of
                    1: (
                            hi: hostInfo;
                    );
                    2: (
                            cacherec: cacheEntryRecord;
                    );
            end;
        DNRRecordPtr = ^DNRRecord;

    type
        PingRecordPtr = ^PingRecord;
        PingCompletionProc = procedure (cbp: IPControlBlockPtr; irp:PingRecordPtr);
        PingRecord = record
                completion: PingCompletionProc;
            end;

    var
        ping_sent_out, ping_got_back: longint;

    procedure StartupTCPUtils;

    function MTTCPCreate(var stream:StreamPtr; buffer:Ptr; buffer_size:longint):OSErr;
    function MTTCPRelease(var stream:StreamPtr):OSErr;
    function MTTCPActiveOpen(var cb:TCPControlBlock; stream:StreamPtr; local_port: ipPort; remote_ip: longint; remote_port: ipPort):OSErr;
    function MTTCPPassiveOpen(var cb:TCPControlBlock; stream:StreamPtr; var local_port: ipPort):OSErr;
    function MTTCPClose(var cb:TCPControlBlock; stream:StreamPtr):OSErr;
    function MTTCPAbort(stream:StreamPtr):OSErr;
    function MTTCPState(stream:StreamPtr):TCPStateType;
    function MTMapState( state: longint): TCPStateType;

    function MTUDPCreate(var stream:StreamPtr; var localport: ipPort; outstanding_count_ptr: LongIntPtr; buffer:Ptr; buffer_size:longint):OSErr;
    function MTUDPRelease (stream:StreamPtr): OSErr;
    function MTUDPRead (stream:StreamPtr; outstanding_count_ptr: LongIntPtr; var remoteip: longint; var remoteport: ipPort;
                                    var datap: Ptr; var datalen: integer): OSErr;
    function MTUDPReturnBuffer (stream:StreamPtr; datap: Ptr): OSErr;
    function MTUDPWrite (stream:StreamPtr; remoteip: longint; remoteport: ipPort;
                                    datap: Ptr; datalen: integer; checksum: boolean): OSErr;

    function MTIPSendPing (remotehost: ipAddr; timeout: integer; datap: Ptr; datalen: integer; complete: PingCompletionProc; irp: PingRecordPtr): OSErr;

    procedure SanitizeHostName (var s: Str255);

    procedure DNRNameToAddr (name: Str255; drp: DNRRecordPtr; completion: DNRCompletionProcPtr);
    procedure DNRNameToHInfo (name: Str255; drp: DNRRecordPtr; completion: DNRCompletionProcPtr);
    procedure DNRAddrToName (addr: longint; drp: DNRRecordPtr; completion: DNRCompletionProcPtr);

    procedure MTZeroTCPCB (var cb: TCPControlBlock; stream: StreamPtr; call: integer);
    procedure MTZeroUDPCB (var cb: UDPControlBlock; stream: StreamPtr; call: integer);

implementation

    uses
        Devices, Memory, Events,
        MyCStrings, MyCallProc, DNR, MyMemory, MyStartup, MyAssertions, PreserveA5;

{$ifc do_debug}
    var
        startup_check: integer;
{$endc}

    var
        gDNRNameToAddrCompletionProc:UniversalProcPtr;
        gDNRAddrToNameCompletionProc:UniversalProcPtr;
        gUDPNotifyProc:UniversalProcPtr;
        gIPPingCompletionProc:UniversalProcPtr;

    procedure MTZeroTCPCB (var cb: TCPControlBlock; stream: StreamPtr; call: integer);
    begin
        MZero(@cb, SizeOf(cb));
        cb.tcpStream := stream;
        cb.ioCRefNum := mactcp_driver_refnum;
        cb.csCode := call;
    end;

    procedure MTZeroUDPCB (var cb: UDPControlBlock; stream: StreamPtr; call: integer);
    begin
        MZero(@cb, SizeOf(cb));
        cb.udpStream := stream;
        cb.ioCRefNum := mactcp_driver_refnum;
        cb.csCode := call;
    end;

    function MTTCPCreate(var stream:StreamPtr; buffer:Ptr; buffer_size:longint):OSErr;
        var
            err:OSErr;
            cb:TCPControlBlock;
    begin
        AssertDidStartup( startup_check );
        MTZeroTCPCB(cb, nil, TCPcsCreate);
        cb.create.rcvBuff := buffer;
        cb.create.rcvBuffLen := buffer_size;
        err := PBControlSync(@cb);
        if err = noErr then begin
            stream := cb.tcpStream;
        end else begin
            stream := nil;
        end;
        MTTCPCreate := err;
    end;

    function MTTCPRelease(var stream:StreamPtr):OSErr;
        var
            cb:TCPControlBlock;
    begin
        MTZeroTCPCB(cb, stream, TCPcsRelease);
        MTTCPRelease := PBControlSync(@cb);
        stream := nil;
    end;

    function MTTCPActiveOpen(var cb:TCPControlBlock; stream:StreamPtr; local_port: ipPort; remote_ip: longint; remote_port: ipPort):OSErr;
    begin
        MTZeroTCPCB(cb, stream, TCPcsActiveOpen);
        cb.open.localport := local_port;
        cb.open.remotehost := remote_ip;
        cb.open.remoteport := remote_port;
        cb.open.ulpTimeoutAction := -1;
        MTTCPActiveOpen := PBControlAsync(@cb);
    end;

    function MTTCPPassiveOpen(var cb:TCPControlBlock; stream:StreamPtr; var local_port: ipPort):OSErr;
        var
            err:OSErr;
    begin
        MTZeroTCPCB(cb, stream, TCPcsPassiveOpen);
        cb.open.localport := local_port;
        cb.open.ulpTimeoutAction := -1;
        err := PBControlAsync(@cb);
        if err = noErr then begin
            while (cb.ioResult>=0) & (cb.open.localport=0) do begin
                ;
            end;
            local_port:=cb.open.localport;
        end;
        MTTCPPassiveOpen := err;
    end;

    function MTTCPClose(var cb:TCPControlBlock; stream:StreamPtr):OSErr;
    begin
        MTZeroTCPCB(cb, stream, TCPcsClose);
        MTTCPClose := PBControlAsync(@cb);
    end;

    function MTTCPAbort(stream:StreamPtr):OSErr;
        var
            cb:TCPControlBlock;
    begin
        MTZeroTCPCB(cb, stream, TCPcsAbort);
        MTTCPAbort := PBControlSync(@cb);
    end;

    function MTMapState( state: longint): TCPStateType;
    begin
        case state of
            0:
                MTMapState := T_Dead;
            2:
                MTMapState := T_Bored;
            4, 6:
                MTMapState := T_Opening;
            8:
                MTMapState := T_Established;
            10, 12, 16, 18, 20:
                MTMapState := T_Closing;
            14:
                MTMapState := T_PleaseClose;
            otherwise begin
                MTMapState := T_Unknown;
            end;
        end;
    end;

    function MTTCPState(stream:StreamPtr):TCPStateType;
        var
            err:OSErr;
            cb:TCPControlBlock;
    begin
        MTZeroTCPCB(cb, stream, TCPcsStatus);
        err := PBControlSync(@cb);
        if err = noErr then begin
            MTTCPState := MTMapState( cb.status.connectionState );
        end else begin
            MTTCPState := T_Dead;
        end;
    end;

    procedure SanitizeHostName (var s: Str255);
    begin
        C2P(@s);
        if s[Length(s)] = '.' then begin
            s[0] := chr(Length(s) - 1);
        end;
    end;

    procedure DNRNameToAddrCompletion (hip: hostInfoPtr; drp: DNRRecordPtr);
    begin
        if hip^.rtnCode = cacheFaultErr then begin
            hip^.rtnCode := noErr; { ARGGGGGHHHHHH }
        end;
        drp^.ioResult := hip^.rtnCode;
        drp^.addr := drp^.hi.addrs[1];
        if drp^.completion <> nil then begin
            CallPascal04(drp, drp^.completion);
        end;
    end;

    procedure DNRNameToAddr (name: Str255; drp: DNRRecordPtr; completion: DNRCompletionProcPtr);
        var
            err: OSErr;
    begin
        drp^.ioResult := 1;
        drp^.name := name;
        drp^.completion := completion;
        err := StrToAddr(name, drp^.hi, gDNRNameToAddrCompletionProc, Ptr(drp));
        if err <> cacheFaultErr then begin
            drp^.hi.rtnCode := err;
            DNRNameToAddrCompletion(@drp^.hi, drp);
        end;
    end;

    procedure DNRNameToHInfo (name: Str255; drp: DNRRecordPtr; completion: DNRCompletionProcPtr);
        var
            err: OSErr;
    begin
        drp^.ioResult := 1;
        drp^.name := name;
        drp^.completion := completion;
        err := HInfo(name, drp^.hi, gDNRNameToAddrCompletionProc, Ptr(drp));
        if err <> cacheFaultErr then begin
            drp^.hi.rtnCode := err;
            DNRNameToAddrCompletion(@drp^.hi, drp);
        end;
    end;

    procedure DNRAddrToNameCompletion (hip: hostInfoPtr; drp: DNRRecordPtr);
    begin
        drp^.ioResult := hip^.rtnCode;
        if drp^.ioResult = noErr then begin
            BlockMoveData(@hip^.rtnHostName, @drp^.name, SizeOf(drp^.name));
            SanitizeHostName(drp^.name);
        end;
        if drp^.completion <> nil then begin
            CallPascal04(drp, drp^.completion);
        end;
    end;

    procedure DNRAddrToName (addr: longint; drp: DNRRecordPtr; completion: DNRCompletionProcPtr);
        var
            err: OSErr;
    begin
        drp^.ioResult := 1;
        drp^.addr := addr;
        drp^.completion := completion;
        AddrToStr(addr, drp^.name);
        err := AddrToName(addr, drp^.hi, gDNRAddrToNameCompletionProc, Ptr(drp));
        if err <> cacheFaultErr then begin
            drp^.hi.rtnCode := err;
            DNRAddrToNameCompletion(@drp^.hi, drp);
        end;
    end;

    procedure UDPNotify (stream: StreamPtr; eventCode: integer; outstanding_count_ptr: LongIntPtr; ignored: Ptr);
    begin
{$unused(stream, ignored)}
        if eventCode = UDPDataArrival then begin
            if outstanding_count_ptr <> nil then begin
                Inc(outstanding_count_ptr^);
            end;
        end;
    end;

    function MTUDPCreate(var stream:StreamPtr; var localport: ipPort; outstanding_count_ptr: LongIntPtr; buffer:Ptr; buffer_size:longint):OSErr;
        var
            err: OSErr;
            cb: UDPControlBlock;
    begin
        MTZeroUDPCB(cb, nil, UDPcsCreate);
        if outstanding_count_ptr <> nil then begin
            outstanding_count_ptr^ := 0;
        end;
        cb.create.rcvBuff := buffer;
        cb.create.rcvBuffLen := buffer_size;
        cb.create.notifyProc := gUDPNotifyProc;
        cb.create.userDataPtr := Ptr(outstanding_count_ptr);
        cb.create.localport := localport;
        err := PBControlSync(@cb);
        if err = noErr then begin
            localport := cb.create.localport;
            stream := cb.udpStream;
        end else begin
            stream := nil;
        end;
        MTUDPCreate := err;
    end;

    function MTUDPRelease (stream:StreamPtr): OSErr;
        var
            err: OSErr;
            cb: UDPControlBlock;
    begin
        MTZeroUDPCB(cb, stream, UDPcsRelease);
        err := PBControlSync(@cb);
        MTUDPRelease := err;
    end;

    function MTUDPRead (stream:StreamPtr; outstanding_count_ptr: LongIntPtr; var remoteip: longint; var remoteport: ipPort;
                                    var datap: Ptr; var datalen: integer): OSErr;
        var
            err: OSErr;
            cb: UDPControlBlock;
    begin
        MTZeroUDPCB(cb, stream, UDPcsRead);
        err := PBControlSync(@cb);
        if (err = noErr) & (outstanding_count_ptr <> nil) then begin
            Dec(outstanding_count_ptr^);
        end;
        remoteip := cb.receive.remoteip;
        remoteport := cb.receive.remoteport;
        datap := cb.receive.rcvBuff;
        datalen := cb.receive.rcvBuffLen;
        MTUDPRead := err;
    end;

    function MTUDPReturnBuffer (stream:StreamPtr; datap: Ptr): OSErr;
        var
            err: OSErr;
            cb: UDPControlBlock;
    begin
        MTZeroUDPCB(cb, stream, UDPcsBfrReturn);
        cb.return.rcvBuff := datap;
        err := PBControlSync(@cb);
        MTUDPReturnBuffer := err;
    end;

    function MTUDPWrite (stream:StreamPtr; remoteip: longint; remoteport: ipPort;
                                    datap: Ptr; datalen: integer; checksum: boolean): OSErr;
        var
            err: OSErr;
            cb: UDPControlBlock;
            wds: wdsType;
    begin
        MTZeroUDPCB(cb, stream, UDPcsWrite);
        cb.send.remoteip := remoteip;
        cb.send.remoteport := remoteport;
        wds.size := datalen;
        wds.buffer := datap;
        wds.term := 0;
        cb.send.wds := @wds;
        cb.send.checksum := ord(checksum);
        err := PBControlSync(@cb);
        MTUDPWrite := err;
    end;

    procedure IPZeroCB (var cb: IPControlBlock; call: integer);
    { Zero out the control block parameters. }
    begin
        MZero(@cb, SizeOf(cb));
        cb.ioCRefNum := mactcp_driver_refnum;
        cb.csCode := call;
    end;

    procedure IPCallCompletion (cbp: IPControlBlockPtr; userdata, extradata: Ptr; addr: UniversalProcPtr);
    begin
        CallPascal0444(cbp,userdata,extradata,addr);
    end;

    procedure IPPingCompletionPascal (cbp: IPControlBlockPtr);
        var
            olda5: Ptr;
            irp: PingRecordPtr;
    begin
        olda5 := SetPreservedA5;
        Inc(ping_got_back);
        irp := PingRecordPtr( cbp^.echoinfo.userDataPtr );
        if (irp <> nil) & (irp^.completion <> nil) then begin
            irp^.completion( cbp, irp );
        end;
        RestoreA5( olda5 );
    end;

{$IFC GENERATINGPOWERPC}
    procedure IPPingCompletion(cbp: IPControlBlockPtr);
    begin
        IPPingCompletionPascal(cbp);
    end;
{$ELSEC}

{$PUSH}
{$ALIGN MAC68K}

    type
        stackframe = packed record
                frameptr: Ptr;
                returnptr: Ptr;
                paramblockptr: Ptr;
            end;
        stackframeptr = ^stackframe;

{$ALIGN RESET}
{$POP}

    function GetStackFrame: stackframeptr;
    inline
        $2E8E;

    procedure IPPingCompletion;
    begin
        IPPingCompletionPascal(IPControlBlockPtr(GetStackFrame^.paramblockptr));
    end;
{$ENDC}

    function MTIPSendPing (remotehost: ipAddr; timeout: integer; datap: Ptr; datalen: integer; completion: PingCompletionProc; irp: PingRecordPtr): OSErr;
        var
            cb: IPControlBlock;
            oe: OSErr;
    begin
        if completion = nil then begin
            Assert( irp = nil );
            irp := nil;
        end;
        if irp <> nil then begin
            irp^.completion := completion;
        end;
        IPZeroCB(cb, TCPcsEchoICMP);
        cb.echo.dest := remotehost;
        cb.echo.data.buffer := datap;
        cb.echo.data.size := datalen;
        cb.echo.timeout := timeout;
        cb.echo.options := nil;
        cb.echo.optlength := 0;
        cb.echo.icmpCompletion := gIPPingCompletionProc;
        cb.echo.userDataPtr := Ptr(irp);
        oe := PBControlSync(@cb);
        if oe = noErr then begin
            Inc(ping_sent_out);
        end;
        MTIPSendPing := oe;
    end;

    function InitTCPUtils(var msg: integer): OSStatus;
    begin
{$unused(msg)}
        DidStartup( startup_check );
        gDNRNameToAddrCompletionProc := NewProc(@DNRNameToAddrCompletion,uppPascal044ProcInfo);
        gDNRAddrToNameCompletionProc := NewProc(@DNRAddrToNameCompletion,uppPascal044ProcInfo);
        gUDPNotifyProc := NewProc(@UDPNotify,uppPascal04244ProcInfo);
        gIPPingCompletionProc := NewProc(@IPPingCompletion, uppC04ProcInfo);
        ping_sent_out := 0;
        ping_got_back := 0;
        InitTCPUtils := noErr;
    end;

    procedure FinishTCPUtils;
        var
            dummy: boolean;
            event: EventRecord;
    begin
        while ping_sent_out > ping_got_back do begin
            dummy := WaitNextEvent( everyEvent, event, 0, nil );
        end;
    end;

    procedure StartupTCPUtils;
    begin
        SetStartup(InitTCPUtils, nil, 0, FinishTCPUtils);
    end;

end.